home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xlsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-12-16  |  4.5 KB  |  215 lines
  1. /* xlsubr - xlisp builtin function support routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *k_test,*k_tnot,*s_eql;
  10. extern NODE *xlstack;
  11.  
  12. /* xlsubr - define a builtin function */
  13. xlsubr(sname,type,subr)
  14.   char *sname; int type; NODE *(*subr)();
  15. {
  16.     NODE *sym;
  17.  
  18.     /* enter the symbol */
  19.     sym = xlsenter(sname);
  20.  
  21.     /* initialize the value */
  22.     sym->n_symvalue = newnode(type);
  23.     sym->n_symvalue->n_subr = subr;
  24. }
  25.  
  26. /* xlarg - get the next argument */
  27. NODE *xlarg(pargs)
  28.   NODE **pargs;
  29. {
  30.     NODE *arg;
  31.  
  32.     /* make sure the argument exists */
  33.     if (!consp(*pargs))
  34.     xlfail("too few arguments");
  35.  
  36.     /* get the argument value */
  37.     arg = car(*pargs);
  38.  
  39.     /* move the argument pointer ahead */
  40.     *pargs = cdr(*pargs);
  41.  
  42.     /* return the argument */
  43.     return (arg);
  44. }
  45.  
  46. /* xlmatch - get an argument and match its type */
  47. NODE *xlmatch(type,pargs)
  48.   int type; NODE **pargs;
  49. {
  50.     NODE *arg;
  51.  
  52.     /* get the argument */
  53.     arg = xlarg(pargs);
  54.  
  55.     /* check its type */
  56.     if (type == LIST) {
  57.     if (arg && ntype(arg) != LIST)
  58.         xlerror("bad argument type",arg);
  59.     }
  60.     else {
  61.     if (arg == NIL || ntype(arg) != type)
  62.         xlerror("bad argument type",arg);
  63.     }
  64.  
  65.     /* return the argument */
  66.     return (arg);
  67. }
  68.  
  69. /* xlevarg - get the next argument and evaluate it */
  70. NODE *xlevarg(pargs)
  71.   NODE **pargs;
  72. {
  73.     NODE *oldstk,val;
  74.  
  75.     /* create a new stack frame */
  76.     oldstk = xlsave(&val,NULL);
  77.  
  78.     /* get the argument */
  79.     val.n_ptr = xlarg(pargs);
  80.  
  81.     /* evaluate the argument */
  82.     val.n_ptr = xleval(val.n_ptr);
  83.  
  84.     /* restore the previous stack frame */
  85.     xlstack = oldstk;
  86.  
  87.     /* return the argument */
  88.     return (val.n_ptr);
  89. }
  90.  
  91. /* xlevmatch - get an evaluated argument and match its type */
  92. NODE *xlevmatch(type,pargs)
  93.   int type; NODE **pargs;
  94. {
  95.     NODE *arg;
  96.  
  97.     /* get the argument */
  98.     arg = xlevarg(pargs);
  99.  
  100.     /* check its type */
  101.     if (type == LIST) {
  102.     if (arg && ntype(arg) != LIST)
  103.         xlerror("bad argument type",arg);
  104.     }
  105.     else {
  106.     if (arg == NIL || ntype(arg) != type)
  107.         xlerror("bad argument type",arg);
  108.     }
  109.  
  110.     /* return the argument */
  111.     return (arg);
  112. }
  113.  
  114. /* xltest - get the :test or :test-not keyword argument */
  115. xltest(pfcn,ptresult,pargs)
  116.   NODE **pfcn; int *ptresult; NODE **pargs;
  117. {
  118.     NODE *arg;
  119.  
  120.     /* default the argument to eql */
  121.     if (!consp(*pargs)) {
  122.     *pfcn = getvalue(s_eql);
  123.     *ptresult = TRUE;
  124.     return;
  125.     }
  126.  
  127.     /* get the keyword */
  128.     arg = car(*pargs);
  129.  
  130.     /* check the keyword */
  131.     if (arg == k_test)
  132.     *ptresult = TRUE;
  133.     else if (arg == k_tnot)
  134.     *ptresult = FALSE;
  135.     else
  136.     xlfail("expecting :test or :test-not");
  137.  
  138.     /* move the argument pointer ahead */
  139.     *pargs = cdr(*pargs);
  140.  
  141.     /* make sure the argument exists */
  142.     if (!consp(*pargs))
  143.     xlfail("no value for keyword argument");
  144.  
  145.     /* get the argument value */
  146.     *pfcn = car(*pargs);
  147.  
  148.     /* if its a symbol, get its value */
  149.     if (symbolp(*pfcn))
  150.     *pfcn = xleval(*pfcn);
  151.  
  152.     /* move the argument pointer ahead */
  153.     *pargs = cdr(*pargs);
  154. }
  155.  
  156. /* xlgetfile - get a file or stream */
  157. NODE *xlgetfile(pargs)
  158.   NODE **pargs;
  159. {
  160.     NODE *arg;
  161.  
  162.     /* get a file or stream (cons) or nil */
  163.     if (arg = xlarg(pargs)) {
  164.     if (filep(arg)) {
  165.         if (arg->n_fp == NULL)
  166.         xlfail("file not open");
  167.     }
  168.     else if (!consp(arg))
  169.         xlerror("bad argument type",arg);
  170.     }
  171.     return (arg);
  172. }
  173.  
  174. /* xllastarg - make sure the remainder of the argument list is empty */
  175. xllastarg(args)
  176.   NODE *args;
  177. {
  178.     if (args)
  179.     xlfail("too many arguments");
  180. }
  181.  
  182. /* eq - internal eq function */
  183. int eq(arg1,arg2)
  184.   NODE *arg1,*arg2;
  185. {
  186.     return (arg1 == arg2);
  187. }
  188.  
  189. /* eql - internal eql function */
  190. int eql(arg1,arg2)
  191.   NODE *arg1,*arg2;
  192. {
  193.     if (eq(arg1,arg2))
  194.     return (TRUE);
  195.     else if (fixp(arg1) && fixp(arg2))
  196.     return (arg1->n_int == arg2->n_int);
  197.     else if (stringp(arg1) && stringp(arg2))
  198.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  199.     else
  200.     return (FALSE);
  201. }
  202.  
  203. /* equal - internal equal function */
  204. int equal(arg1,arg2)
  205.   NODE *arg1,*arg2;
  206. {
  207.     /* compare the arguments */
  208.     if (eql(arg1,arg2))
  209.     return (TRUE);
  210.     else if (consp(arg1) && consp(arg2))
  211.     return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
  212.     else
  213.     return (FALSE);
  214. }
  215.